home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / MATH / LGSOLV1.ZIP / DEMOTEST.FOR < prev    next >
Text File  |  1992-12-01  |  9KB  |  287 lines
  1.       INCLUDE 'FGRAPH.FI'
  2.       program demotest
  3. C         1.  Objects for  LGSOLV :
  4.       PARAMETER(MAXBUF=8005)
  5.       PARAMETER(MAXDIM=1000)
  6.       common/buf1/b1(MAXBUF)
  7.       common/buf2/b2(MAXBUF)
  8.       real*8 b1,b2,g1sol,g1emat,g1fmat,g1rp
  9.       external elmatr,elvect
  10.       real*8 elmatr,elvect
  11. C         2.  Objects for  Screen Output  and  Random Generator :
  12.       INCLUDE  'FGRAPH.FD'
  13.       RECORD / rccoord / curpos
  14.       COMMON /grand/ rand,rseed
  15.       INTEGER*2          dummy2,rseed
  16.       INTEGER*4          dummy4
  17.       REAL*4             rand
  18. C
  19. C         3.  Objects for  Demo Test :
  20.       common /btest/ mt,nex,t1,umm(5,5),v(maxdim)
  21.       real*8 v,umm,x,s1,s2,s11,s12
  22.       CHARACTER*36 str
  23.       character*30 diagn(4)
  24.       INTEGER*2 th,tm,ts
  25.       integer*4 t1,t2,lb,lw,n,nc
  26.       data lb/1000/, lw/8/, n/10/, nc/1/, last/0/
  27.       data umm/ 1.0, 1.0, 0.0, 0.0, 0.0,
  28.      *          2.0, 2.0, 0.0, 0.0, 0.0,
  29.      *          1.0, 0.0, 3.0, 0.0, 0.0,
  30.      *          0.0, 0.0, 0.0, 1.0, 0.0,
  31.      *          0.0, 0.0, 0.0, 0.0, 0.0 /
  32.       data diagn/30HSingular matrix !!!            ,
  33.      *           30HSystem buffers are too small ! ,
  34.      *           30HInsufficient disk-space !!!    ,
  35.      *           30H                               /
  36. C
  37.       mt=2
  38.    1  dummy4 = setbkcolor( 7 )
  39.       dummy2 = settextcolor( 15 )
  40.       CALL clearscreen( $GCLEARSCREEN )
  41.       CALL settextposition( 1,20,curpos )
  42.       CALL outtext( 'LGSOLV Demo Test.' )
  43.       dummy2 = settextcolor( 0 )
  44.   12  lb=inpnum(4,40,'Buffer Size           : ',2,maxbuf,lb)
  45.       n =inpnum(5,40,'System Dimension      : ',2,maxdim,n)
  46.       CALL settextposition( 7,40,curpos )
  47.       call outtext(  ' ( -1 means Matrix Inversion ! )')
  48.       nc=inpnum(6,40,'Number of Right Parts : ',-1,maxdim,nc)
  49.       CALL settextposition( 6,2,curpos )
  50.       CALL settextposition( 8,40,curpos )
  51.       call outtext(  ' ( 4 or 8 bytes per word ) ')
  52.       lw=inpnum(7,40,'Matrix packing factor : ',4,8,lw)
  53.       CALL settextposition( 9,40,curpos )
  54.       call outtext(  ' ( 1-E, 2-Random, 3-Singular )')
  55.       j=3
  56.       if(n.le.5) j=4
  57.       mt=inpnum(8,40,'Matrix type for test  : ',1,j,mt)
  58. C
  59. C    ....  Random Generator Initialize
  60.       call gettim(th,tm,ts,rseed)
  61.       t1=3600*th+60*tm+ts
  62.       rseed=int2(100*t1+rseed)
  63.       call seed(rseed)
  64.       nex=0
  65.       i=10*n+mt-last
  66.       if(i.ne.0.or.nc.lt.0) goto 122
  67.       call settextposition(12,22,curpos)
  68.       call outtext('Matrix was given and factorized last time !')
  69.       goto 123
  70.  122  dummy4 = setbkcolor( 3 )
  71.       dummy2 = settextcolor( 15 )
  72.       call settextposition(13,20,curpos)
  73.       str(1:1)='P'
  74.       if(nc.lt.0) str(1:1)='V'
  75.       call outtext('  mer = LGMIN'//str(1:1)//'(')
  76.       call outnum(lb)
  77.       call outtext(',')
  78.       call outnum(lw)
  79.       call outtext(',')
  80.       call outnum(n)
  81.       call outtext(',elmfun)          ')
  82.       dummy4 = setbkcolor( 7 )
  83.       dummy2 = settextcolor( 0 )
  84.       if(nc.gt.0) nerror=lgminp( lb, lw, n, elmatr )
  85.       if(nc.le.0) nerror=lgminv( lb, lw, n, elmatr )
  86.       if(nerror.ne.0.or.nc.le.0) goto 2
  87.  123  dummy4 = setbkcolor( 3 )
  88.       dummy2 = settextcolor( 15 )
  89.       call settextposition(13,20,curpos)
  90.       call outtext('  mer = LGSOLV(')
  91.       call outnum(nc)
  92.       call outtext(',rpsfun)          ')
  93.       dummy4 = setbkcolor( 7 )
  94.       dummy2 = settextcolor( 0 )
  95.       nerror=lgsolv(nc,elvect)
  96. C
  97.   2   call gettim(th,tm,ts,dummy2)
  98.       t2=3600*th+60*tm+ts
  99.       last=0
  100.       CALL settextposition( 9,2, curpos )
  101.       if(nerror.ne.0) call outtext('Error code='//
  102.      *   char(nerror+48)//' : '//diagn(nerror))
  103.       if(nerror.ne.0) goto 9
  104.       call vist('Results reading and checking ...         ')
  105.       s11=0.0D0
  106.       s12=0.0D0
  107.       ncc=iabs(nc)
  108.       dummy4 = setbkcolor( 3 )
  109.       dummy2 = settextcolor( 15 )
  110.       call settextposition(13,20,curpos)
  111.       if(nc.gt.0) call outtext('  x = G1SOL(i,j)                  ')
  112.       if(nc.lt.0) call outtext('  x = G1EMAT(i,j)                 ')
  113.       dummy4 = setbkcolor( 7 )
  114.       dummy2 = settextcolor( 0 )
  115.       do 5 j=1,ncc
  116.       s1=0.0D0
  117.       s2=0.0D0
  118.       if(nc.gt.0) then
  119.       do 6 i=1,n
  120.       x=g1sol(i,j)-dble(i*j)
  121.       if(DABS(x).gt.s1) s1=DABS(x)
  122.   6   s2=s2+x*x
  123.       else
  124.       call seed(rseed)
  125.       x=0.0D0
  126.       do 7 i=1,n
  127.   7   x=x+g1emat(1,i)*elmatr(i,1)
  128.       if(j.eq.1) x=x-1.0D0
  129.       s1=DABS(x)
  130.       s2=x*x
  131.       endif
  132.       if(s2.gt.s12) s12=s2
  133.       if(s1.gt.s11) s11=s1
  134.       write(str,'(2d7.2)') s11,s12
  135.       CALL settextposition( 7,2, curpos )
  136.       call outtext('Max Mod Error : '//str(1:7)//char(0))
  137.       CALL settextposition( 8,2, curpos )
  138.       call outtext('Summ Err**2   : '//str(8:14)//char(0))
  139.   5   continue
  140.       if(nc.gt.0) last=10*n+mt
  141.   9   CALL settextposition( 10,2, curpos )
  142.       dummy2 = settextcolor( 0 )
  143.       call outtext('Quit (Y/N) : ')
  144.       read(*,'(a1)') str(1:1)
  145.       if(str(1:1).ne.'Y'.and.str(1:1).ne.'y') goto 1
  146.       end
  147.  
  148.       integer function inpnum(nr,nc,title,min,max,ndef)
  149.       character*(*) title
  150.       INCLUDE  'FGRAPH.FD'
  151.       RECORD / rccoord / curpos,cp1
  152.       character*6 str
  153.     numb=0
  154.   1   call settextposition(nr,nc,curpos)
  155.       call outtext( title )
  156.       write(str,'(i6)') ndef
  157.       call outtext(str//'   ')
  158.       call gettextposition(cp1)
  159.       read(*,'(i6)') numb
  160.     if(numb.eq.0) numb=ndef
  161.       call settextposition(cp1.row,cp1.col,curpos)
  162.       call outtext('         ')
  163.       if(numb.lt.min.or.numb.gt.max) goto 1
  164.       call settextposition(nr,nc,curpos)
  165.       call outtext( title )
  166.       write(str,'(i6)') numb
  167.       call outtext(str)
  168.       inpnum=numb
  169.       return
  170.       end
  171.  
  172.       subroutine outnum(n)
  173.       character*12 s
  174.       write(s,'(i12)') n
  175.       do 1 j=1,12
  176.       i=j
  177.       if(s(i:i).ne.' ') goto 2
  178.   1     continue
  179.   2   call outtext(s(i:12))
  180.       return
  181.     end
  182.  
  183.       subroutine vis0(m1,m2,job)
  184.       INCLUDE  'FGRAPH.FD'
  185.       RECORD / rccoord / curpos,cp1
  186.       integer*2 d,m1,m2,th,tm,ts
  187.       character*(*) title
  188.       real*8 price
  189.       common /btest/ mt,nex,nt1
  190.       character*6 kb
  191.       character*50 s,bs
  192.       SAVE
  193.       data  s/'██████████████████████████████████████████████████'/
  194.       data bs/'                                                  '/
  195.     call gettextposition(cp1)
  196.       if(m1.gt.0) max1=m1
  197.       if(m2.gt.0) max2=m2
  198.       price=50.0D0 / DBLE(max2)
  199.       i4 = setbkcolor( 7 )
  200.       d  = settextcolor( 15 )
  201.       CALL settextposition( 18,2,curpos )
  202.       CALL outtext( 'Disk Exchange Diagramm : ' )
  203.       d  = settextcolor( 0 )
  204.       CALL settextposition( 20,2,curpos )
  205.       call outtext('Input  matrix:    '//s)
  206.       CALL settextposition( 22,2,curpos )
  207.       call outtext('Factor-matrix:    '//s)
  208.       CALL settextposition( 24,2,curpos )
  209.       call outtext('matrix')
  210.       if(max1.lt.max2) call outtext('+right parts')
  211.       call outtext('=')
  212.       call outnum(max2)
  213.       call outtext(' bl.')
  214.       k=int(price)
  215.       if(k.eq.0) k=1
  216.       call outtext('  1 block')
  217.       if(max2.gt.2) call outtext(' '//s(1:k))
  218.       call outtext(' = ')
  219.       call outnum(job)
  220.       call outtext(' bytes.')
  221.       d  = settextcolor( 4 )
  222.       call outtext('  '//s(1:1)//'-Write,')
  223.       d  = settextcolor( 1 )
  224.       call outtext('  '//s(1:1)//'-Read.')
  225.       d  = settextcolor( 0 )
  226.       goto 100
  227.  
  228.       entry vist(title)
  229.       call gettextposition(cp1)
  230.       CALL settextposition( 18,28,curpos )
  231.       d = settextcolor( 0 )
  232.       call outtext(title)
  233.       goto 200
  234.  
  235.       entry vis(m1,m2,job)
  236.       nex=nex+1
  237.       npos=18+2*m1
  238.       call gettextposition(cp1)
  239.       k=4
  240.       if(job.ne.0) k=1
  241.       d=settextcolor(k)
  242.       k1=int( price*DBLE(m2-1) )
  243.       call settextposition(npos,20+k1,curpos)
  244.       k=1+int( price*DBLE(m2) )
  245.       if(k.gt.50) k=50
  246.       call outtext(s(k1+1:k))
  247.       d=settextcolor(0)
  248.       call settextposition(npos+1,21,curpos)
  249.       bs(k1:k1)=''
  250.       call outtext(bs)
  251.       bs(k1:k1)=' '
  252.  200  call gettim(th,tm,ts,d)
  253.       nt2=3600*th+60*tm+ts
  254.       CALL settextposition( 5,2,curpos )
  255.       call outtext('Number of exchanges: ')
  256.       call outnum(nex)
  257.       call settextposition( 4,2,curpos)
  258.       call outtext('Elapsed Time (sec) : ')
  259.       call outnum(nt2-nt1)
  260.  100  call settextposition(cp1.row,cp1.col,curpos)
  261.       return
  262.       end
  263.  
  264.       real*8 function elmatr(i,j)
  265.       integer*2 i,j
  266.       common /grand/ r
  267.       REAL*4 r
  268.       common /btest/ mt,nex,nt1,umm(5,5),v(2)
  269.       real*8 v,umm,elvect
  270.  
  271.       elmatr=0.0D0
  272.       if(i.eq.j) elmatr=1.0D0
  273.       if(mt.eq.1) goto 1
  274.       CALL RANDOM(r)
  275.       elmatr=1.0D1*(0.5D0-DBLE(r))
  276.       if(mt.eq.2) goto 1
  277.       if(j.eq.2) elmatr=v(i)*3.0D0
  278.       if(mt.eq.4) elmatr=umm(i,j)
  279.   1   if(j.eq.1) v(i)=elmatr
  280.       if(j.ne.1) v(i)=v(i)+elmatr*DBLE(j)
  281.       return
  282.       entry elvect(i,j)
  283.       elvect=v(i)*DBLE(j)
  284.       return
  285.       end
  286.  
  287.